home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / RMISC.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  48.8 KB  |  1,890 lines
  1. /*
  2.  * File: rmisc.r
  3.  *  Contents: deref, eq, [gcvt], getvar, hash, outimage,
  4.  *  qtos, pushact, popact, topact, [dumpact], 
  5.  *  findline, findipc, findfile, doimage, getimage
  6.  *  printable, sig_rsm, cmd_line, varargs.
  7.  *
  8.  *  Integer overflow checking.
  9.  */
  10.  
  11. #ifdef IconAlloc
  12. #define free mem_free
  13. #endif                    /* IconAlloc */
  14.  
  15. /*
  16.  * Prototypes.
  17.  */
  18.  
  19. hidden novalue    listimage
  20.    Params((FILE *f,struct b_list *lp, int restrict));
  21. hidden novalue    printimage    Params((FILE *f,int c,int q));
  22. hidden char *    csname        Params((dptr dp));
  23.  
  24. hidden novalue    showlevel    Params((int n));
  25. hidden novalue    showline    Params((char *f,int l));
  26.  
  27. /* 
  28.  * eq - compare two Icon strings for equality
  29.  */
  30. int eq(d1, d2)
  31. dptr d1, d2;
  32. {
  33.     char *s1, *s2;
  34.     int i;
  35.  
  36.     if (StrLen(*d1) != StrLen(*d2))
  37.        return 0;
  38.     s1 = StrLoc(*d1);
  39.     s2 = StrLoc(*d2);
  40.     for (i = 0; i < StrLen(*d1); i++)
  41.        if (*s1++ != *s2++) 
  42.           return 0;
  43.     return 1;
  44. }
  45.  
  46. #ifdef IconGcvt
  47. /*
  48.  * gcvt - Convert number to a string in buf.  If possible, ndigit
  49.  *  significant digits are produced, otherwise a form with an exponent is used.
  50.  *
  51.  */
  52. char *gcvt(number, ndigit, buf)
  53. double number;
  54. int ndigit;
  55. char *buf;
  56.    {
  57.    int sign, decpt;
  58.    register char *p1, *p2;
  59.    register i;
  60.  
  61. #if AMIGA
  62. #if AZTEC_C
  63.    /* shameless kludge around C library deficiency */
  64. #define ecvt(w,x,y,z) 0
  65.  
  66.    ftoa(number,buf,ndigit,2);            /* 2 is MANX for "G" format */
  67.    for(i=strlen(buf); i>1 && buf[i-1]=='0' && buf[i-2]!='.'; i--)
  68.       buf[i-1] = '\0';
  69.    return buf;
  70. #endif                    /* AZTEC_C */
  71. #endif                    /* AMIGA */
  72.  
  73.    p1 = ecvt(number, ndigit, &decpt, &sign);
  74.    p2 = buf;
  75.    if (sign)
  76.       *p2++ = '-';
  77.    for (i=ndigit-1; i>0 && p1[i]=='0'; i--)
  78.       ndigit--;
  79.    if (decpt >= 0 && decpt-ndigit > 4
  80.       || decpt < 0 && decpt < -3) { /* use E-style */
  81.          decpt--;
  82.          *p2++ = *p1++;
  83.          *p2++ = '.';
  84.          for (i=1; i<ndigit; i++)
  85.             *p2++ = *p1++;
  86.          *p2++ = 'e';
  87.          if (decpt<0) {
  88.             decpt = -decpt;
  89.             *p2++ = '-';
  90.             }
  91.          else
  92.             *p2++ = '+';
  93.          if (decpt/100 > 0)
  94.             *p2++ = decpt/100 + '0';
  95.          if (decpt/10 > 0)
  96.             *p2++ = (decpt%100)/10 + '0';
  97.          *p2++ = decpt%10 + '0';
  98.       } else {
  99.          if (decpt<=0) {
  100.          /* if (*p1!='0') */
  101.          *p2++ = '0';
  102.          *p2++ = '.';
  103.          while (decpt<0) {
  104.             decpt++;
  105.             *p2++ = '0';
  106.             }
  107.          }
  108.          for (i=1; i<=ndigit; i++) {
  109.             *p2++ = *p1++;
  110.             if (i==decpt)
  111.                *p2++ = '.';
  112.             }
  113.       if (ndigit<decpt) {
  114.          while (ndigit++<decpt)
  115.             *p2++ = '0';
  116.          *p2++ = '.';
  117.          }
  118.    }
  119.    if (p2[-1]=='.')
  120.       *p2++ = '0';
  121.    *p2 = '\0';
  122.  
  123.    return(buf);
  124.    }
  125. #endif                    /* IconGcvt */
  126.  
  127. #if COMPILER
  128. /*
  129.  * Get variable descriptor from name.
  130.  */
  131. int getvar(s,vp)
  132.    char *s;
  133.    dptr vp;
  134.    {
  135.    struct descrip sdp;
  136.    register dptr dp;
  137.    register dptr np;
  138.    register int i;
  139.    struct b_proc *bp;
  140.  
  141.    if (!debug_info) 
  142.       fatalerr(402,NULL);
  143.  
  144.    StrLoc(sdp) = s;
  145.    StrLen(sdp) = strlen(s);
  146.    /*
  147.     * Is it a keyword that's a variable?
  148.     */
  149.    if (*s == '&') {
  150.  
  151.       if (strcmp(s,"&error") == 0) {    /* must put basic one first */
  152.          *vp = kywd_err;
  153.          return Succeeded;
  154.          }
  155.  
  156.  
  157.  
  158.  
  159.       else if (strcmp(s,"&pos") == 0) {
  160.          *vp = kywd_pos;
  161.          return Succeeded;
  162.          }
  163.       else if (strcmp(s,"&random") == 0) {
  164.          *vp = kywd_ran;
  165.          return Succeeded;
  166.          }
  167.       else if (strcmp(s,"&subject") == 0) {
  168.          *vp = k_subject;
  169.          return Succeeded;
  170.          }
  171.       else if (strcmp(s,"&trace") == 0) {
  172.          *vp = kywd_trc;
  173.          return Succeeded;
  174.          }
  175.  
  176.       else return Failed;
  177.       }
  178.  
  179.    /* Look for the variable the name with the local identifiers,
  180.     *  parameters, and static names in each Icon procedure frame on the
  181.     *  stack. If not found among the locals, check the global variables.
  182.     *  If a variable with name is found, variable() returns a variable
  183.     *  descriptor that points to the corresponding value descriptor. 
  184.     *  If no such variable exits, it fails.
  185.     */
  186.  
  187.    bp = PFDebug(*pfp)->proc;  /* get address of procedure block */
  188.    
  189.    np = bp->lnames;        /* Check the formal parameter names. */
  190.    dp = argp;
  191.    for (i = abs(bp->nparam); i > 0; i--) {
  192.       if (eq(&sdp, np) == 1) {
  193.          vp->dword = D_Var;
  194.          VarLoc(*vp) = (dptr)dp;
  195.          return Succeeded;
  196.          }
  197.       np++;
  198.       dp++;
  199.       }
  200.  
  201.       dp = &pfp->tend.d[0];
  202.       for (i = bp->ndynam; i > 0; i--) { /* Check the local dynamic names. */
  203.          if (eq(&sdp, np)) {
  204.             vp->dword = D_Var;
  205.             VarLoc(*vp) = (dptr)dp;
  206.             return Succeeded;
  207.         }
  208.          np++;
  209.          dp++;
  210.          }
  211.  
  212.       dp = &statics[bp->fstatic]; /* Check the local static names. */
  213.       for (i = bp->nstatic; i > 0; i--) {
  214.          if (eq(&sdp, np)) {
  215.             vp->dword = D_Var;
  216.             VarLoc(*vp) = (dptr)dp;
  217.             return Succeeded;
  218.         }
  219.          np++;
  220.          dp++;
  221.          }
  222.  
  223.       for (i = 0; i < n_globals; ++i) {
  224.          if (eq(&sdp, &gnames[i])) {
  225.             vp->dword = D_Var;
  226.             VarLoc(*vp) = (dptr)&globals[i];
  227.             return Succeeded;
  228.         }
  229.          }
  230.    return Failed; 
  231.    }
  232. #else                    /* COMPILER */
  233. /*
  234.  * Get variable descriptor from name.
  235.  */
  236.  
  237. int getvar(s,vp)
  238.    char *s;
  239.    dptr vp;
  240.    {
  241.    register dptr dp;
  242.    register dptr np;
  243.    register int i;
  244.    struct b_proc *bp;
  245.    struct pf_marker *fp = pfp;
  246.  
  247.    /*
  248.     * Is it a keyword that's a variable?
  249.     */
  250.    if (*s == '&') {
  251.  
  252.       if (strcmp(s,"&error") == 0) {    /* must put basic one first */
  253.          *vp = kywd_err;
  254.          return Succeeded;
  255.          }
  256.  
  257.  
  258.  
  259.  
  260.       else if (strcmp(s,"&pos") == 0) {
  261.          *vp = kywd_pos;
  262.          return Succeeded;
  263.          }
  264.       else if (strcmp(s,"&random") == 0) {
  265.          *vp = kywd_ran;
  266.          return Succeeded;
  267.          }
  268.       else if (strcmp(s,"&subject") == 0) {
  269.          *vp = k_subject;
  270.          return Succeeded;
  271.          }
  272.       else if (strcmp(s,"&trace") == 0) {
  273.          *vp = kywd_trc;
  274.          return Succeeded;
  275.          }
  276.  
  277.  
  278.       else return Failed;
  279.       }
  280.  
  281. /*
  282.  * Look for the variable with the name of the local identifiers,
  283.  *  parameters, and static names in each Icon procedure frame on the stack.
  284.  *  If not found among the locals, check the global variables.
  285.  *  If a variable with name is found, variable() returns a variable
  286.  *  descriptor that points to the corresponding value descriptor. 
  287.  *  If no such variable exits, it fails.
  288.  */
  289.       
  290.    /*
  291.     *  If no procedure has been called (as can happen with icon_call(),
  292.     *  dont' try to find local identifier.
  293.     */
  294.    if (pfp == NULL)
  295.       goto glbvars;
  296.    dp = argp;
  297.    bp = (struct b_proc *)BlkLoc(*dp);    /* get address of procedure block */
  298.    
  299.    np = bp->lnames;        /* Check the formal parameter names. */
  300.    for (i = abs((int)bp->nparam); i > 0; i--) {
  301.       dp++;
  302.       if (strcmp(s,StrLoc(*np)) == 0) {
  303.          vp->dword = D_Var;
  304.          VarLoc(*vp) = (dptr)dp;
  305.          return Succeeded;
  306.          }
  307.       np++;
  308.       }
  309.  
  310.    dp = &fp->pf_locals[0];
  311.    for (i = (int)bp->ndynam; i > 0; i--) { /* Check the local dynamic names. */
  312.       if (strcmp(s,StrLoc(*np)) == 0) {
  313.          vp->dword = D_Var;
  314.          VarLoc(*vp) = (dptr)dp;
  315.          return Succeeded;
  316.          }
  317.       np++;
  318.       dp++;
  319.       }
  320.  
  321.    dp = &statics[bp->fstatic]; /* Check the local static names. */
  322.    for (i = (int)bp->nstatic; i > 0; i--) {
  323.       if (strcmp(s,StrLoc(*np)) == 0) {
  324.          vp->dword = D_Var;
  325.          VarLoc(*vp) = (dptr)dp;
  326.          return Succeeded;
  327.          }
  328.       np++;
  329.       dp++;
  330.       }
  331.  
  332. glbvars:
  333.    dp = globals;    /* Check the global variable names. */
  334.    np = gnames;
  335.    while (dp < eglobals) {
  336.       if (strcmp(s,StrLoc(*np)) == 0) {
  337.          vp->dword    =  D_Var;
  338.          VarLoc(*vp) =  (dptr)(dp);
  339.          return Succeeded;
  340.          }
  341.       np++;
  342.       dp++;
  343.       }
  344.    return Failed;
  345. }
  346. #endif                    /* !COMPILER */
  347.  
  348. /*
  349.  * hash - compute hash value of arbitrary object for table and set accessing.
  350.  */
  351.  
  352. uword hash(dp)
  353. dptr dp;
  354.    {
  355.    register char *s;
  356.    register uword i;
  357.    register word j, n;
  358.    register int *bitarr;
  359.    double r;
  360.  
  361.    if (Qual(*dp)) {
  362.  
  363.       /*
  364.        * Compute the hash value for the string based on a scaled sum
  365.        *  of its first ten characters, plus its length.
  366.        */
  367.       i = 0;
  368.       s = StrLoc(*dp);
  369.       j = n = StrLen(*dp);
  370.       if (j > 10)        /* limit scan to first ten characters */
  371.          j = 10;
  372.       while (j-- > 0) {
  373.          i += *s++ & 0xFF;    /* add unsigned version of next char */
  374.          i *= 37;        /* scale total by a nice prime number */
  375.          }
  376.       i += n;            /* add the (untruncated) string length */
  377.       }
  378.  
  379.    else {
  380.  
  381.       switch (Type(*dp)) {
  382.          /*
  383.           * The hash value of an integer is itself times eight times the golden
  384.       *  ratio.  We do this calculation in fixed point.  We don't just use
  385.       *  the integer itself, for that would give bad results with sets
  386.       *  having entries that are multiples of a power of two.
  387.           */
  388.          case T_Integer:
  389.             i = (13255 * (uword)IntVal(*dp)) >> 10;
  390.             break;
  391.  
  392. #ifdef LargeInts
  393.          /*
  394.           * The hash value of a bignum is based on its length and its
  395.           *  most and least significant digits.
  396.           */
  397.      case T_Lrgint:
  398.         {
  399.         struct b_bignum *b = &BlkLoc(*dp)->bignumblk;
  400.  
  401.         i = ((b->lsd - b->msd) << 16) ^ 
  402.         (b->digits[b->msd] << 8) ^ b->digits[b->lsd];
  403.         }
  404.         break;
  405. #endif                    /* LargeInts */
  406.  
  407.          /*
  408.           * The hash value of a real number is itself times a constant,
  409.           *  converted to an unsigned integer.  The intent is to scramble
  410.       *  the bits well, in the case of integral values, and to scale up
  411.       *  fractional values so they don't all land in the same bin.
  412.       *  The constant below is 32749 / 29, the quotient of two primes,
  413.       *  and was observed to work well in empirical testing.
  414.           */
  415.          case T_Real:
  416.             GetReal(dp,r);
  417.             i = r * 1129.27586206896558;
  418.             break;
  419.  
  420.          /*
  421.           * The hash value of a cset is based on a convoluted combination
  422.           *  of all its bits.
  423.           */
  424.          case T_Cset:
  425.             i = 0;
  426.             bitarr = BlkLoc(*dp)->cset.bits + CsetSize - 1;
  427.             for (j = 0; j < CsetSize; j++) {
  428.                i += *bitarr--;
  429.                i *= 37;            /* better distribution */
  430.                }
  431.             i %= 1048583;        /* scramble the bits */
  432.             break;
  433.  
  434.          /*
  435.           * The hash value of a list, set, table, or record is its id,
  436.           *   hashed like an integer.
  437.           */
  438.          case T_List:
  439.             i = (13255 * BlkLoc(*dp)->list.id) >> 10;
  440.             break;
  441.  
  442.          case T_Set:
  443.             i = (13255 * BlkLoc(*dp)->set.id) >> 10;
  444.             break;
  445.  
  446.          case T_Table:
  447.             i = (13255 * BlkLoc(*dp)->table.id) >> 10;
  448.             break;
  449.  
  450.          case T_Record:
  451.             i = (13255 * BlkLoc(*dp)->record.id) >> 10;
  452.             break;
  453.  
  454.          default:
  455.             /*
  456.              * For other types, use the type code as the hash
  457.              *  value.
  458.              */
  459.             i = Type(*dp);
  460.             break;
  461.          }
  462.       }
  463.  
  464.    return i;
  465.    }
  466.  
  467.  
  468. #define StringLimit    16        /* limit on length of imaged string */
  469. #define ListLimit     6        /* limit on list items in image */
  470.  
  471. /*
  472.  * outimage - print image of *dp on file f.  If restrict is nonzero,
  473.  *  fields of records will not be imaged.
  474.  */
  475.  
  476. novalue outimage(f, dp, restrict)
  477. FILE *f;
  478. dptr dp;
  479. int restrict;
  480.    {
  481.    register word i, j;
  482.    register char *s;
  483.    register union block *bp;
  484.    char *type, *csn;
  485.    FILE *fd;
  486.    struct descrip q;
  487.    double rresult;
  488.    tended struct descrip tdp;
  489.  
  490.    type_case *dp of {
  491.       string: {
  492.          /*
  493.           * *dp is a string qualifier.  Print StringLimit characters of it
  494.           *  using printimage and denote the presence of additional characters
  495.           *  by terminating the string with "...".
  496.           */
  497.          i = StrLen(*dp);
  498.          s = StrLoc(*dp);
  499.          j = Min(i, StringLimit);
  500.          putc('"', f);
  501.          while (j-- > 0)
  502.             printimage(f, *s++, '"');
  503.          if (i > StringLimit)
  504.             fprintf(f, "...");
  505.          putc('"', f);
  506.          }
  507.  
  508.       null:
  509.          fprintf(f, "&null");
  510.  
  511.       integer:
  512.  
  513. #ifdef LargeInts
  514.          if (Type(*dp) == T_Lrgint)
  515.             bigprint(f, dp);
  516.          else
  517.             fprintf(f, "%ld", (long)IntVal(*dp));
  518. #else                    /* LargeInts */
  519.          fprintf(f, "%ld", (long)IntVal(*dp));
  520. #endif                    /* LargeInts */
  521.  
  522.       real: {
  523.          char s[30];
  524.          struct descrip rd;
  525.  
  526.          GetReal(dp,rresult);
  527.          rtos(rresult, &rd, s);
  528.          fprintf(f, "%s", StrLoc(rd));
  529.          }
  530.  
  531.       cset: {
  532.          /*
  533.       * Check for a predefined cset; use keyword name if found.
  534.       */
  535.      if ((csn = csname(dp)) != NULL) {
  536.         fprintf(f, csn);
  537.         return;
  538.         }
  539.          /*
  540.           * Use printimage to print each character in the cset.  Follow
  541.           *  with "..." if the cset contains more than StringLimit
  542.           *  characters.
  543.           */
  544.          putc('\'', f);
  545.          j = StringLimit;
  546.          for (i = 0; i < 256; i++) {
  547.             if (Testb(i, *dp)) {
  548.                if (j-- <= 0) {
  549.                   fprintf(f, "...");
  550.                   break;
  551.                   }
  552.                printimage(f, (int)i, '\'');
  553.                }
  554.             }
  555.          putc('\'', f);
  556.          }
  557.  
  558.       file: {
  559.          /*
  560.           * Check for distinguished files by looking at the address of
  561.           *  of the object to image.  If one is found, print its name.
  562.           */
  563.          if ((fd = BlkLoc(*dp)->file.fd) == stdin)
  564.             fprintf(f, "&input");
  565.          else if (fd == stdout)
  566.             fprintf(f, "&output");
  567.          else if (fd == stderr)
  568.             fprintf(f, "&errout");
  569.          else {
  570.             /*
  571.              * The file isn't a special one, just print "file(name)".
  572.              */
  573.             i = StrLen(BlkLoc(*dp)->file.fname);
  574.             s = StrLoc(BlkLoc(*dp)->file.fname);
  575.             fprintf(f, "file(");
  576.             while (i-- > 0)
  577.                printimage(f, *s++, '\0');
  578.             putc(')', f);
  579.             }
  580.          }
  581.  
  582.       procedure: {
  583.          /*
  584.           * Produce one of:
  585.           *  "procedure name"
  586.           *  "function name"
  587.           *  "record constructor name"
  588.           *
  589.           * Note that the number of dynamic locals is used to determine
  590.           *  what type of "procedure" is at hand.
  591.           */
  592.          i = StrLen(BlkLoc(*dp)->proc.pname);
  593.          s = StrLoc(BlkLoc(*dp)->proc.pname);
  594.          switch ((int)BlkLoc(*dp)->proc.ndynam) {
  595.             default:  type = "procedure"; break;
  596.             case -1:  type = "function"; break;
  597.             case -2:  type = "record constructor"; break;
  598.             }
  599.          fprintf(f, "%s ", type);
  600.          while (i-- > 0)
  601.             printimage(f, *s++, '\0');
  602.          }
  603.  
  604.       list: {
  605.          /*
  606.           * listimage does the work for lists.
  607.           */
  608.          listimage(f, (struct b_list *)BlkLoc(*dp), restrict);
  609.          }
  610.  
  611.       table: {
  612.          /*
  613.           * Print "table_m(n)" where n is the size of the table.
  614.           */
  615.          fprintf(f, "table_%ld(%ld)", (long)BlkLoc(*dp)->table.id,
  616.             (long)BlkLoc(*dp)->table.size);
  617.          }
  618.  
  619.       set: {
  620.     /*
  621.          * print "set_m(n)" where n is the cardinality of the set
  622.          */
  623.     fprintf(f,"set_%ld(%ld)",(long)BlkLoc(*dp)->set.id,
  624.            (long)BlkLoc(*dp)->set.size);
  625.         }
  626.  
  627.       record: {
  628.          /*
  629.           * If restrict is nonzero, print "record(n)" where n is the
  630.           *  number of fields in the record.  If restrict is zero, print
  631.           *  the image of each field instead of the number of fields.
  632.           */
  633.          bp = BlkLoc(*dp);
  634.          i = StrLen(bp->record.recdesc->proc.recname);
  635.          s = StrLoc(bp->record.recdesc->proc.recname);
  636.          fprintf(f, "record ");
  637.          while (i-- > 0)
  638.             printimage(f, *s++, '\0');
  639.         fprintf(f, "_%ld", bp->record.id);
  640.          j = bp->record.recdesc->proc.nfields;
  641.          if (j <= 0)
  642.             fprintf(f, "()");
  643.          else if (restrict > 0)
  644.             fprintf(f, "(%ld)", (long)j);
  645.          else {
  646.             putc('(', f);
  647.             i = 0;
  648.             for (;;) {
  649.                outimage(f, &bp->record.fields[i], restrict+1);
  650.                if (++i >= j)
  651.                   break;
  652.                putc(',', f);
  653.                }
  654.             putc(')', f);
  655.             }
  656.          }
  657.  
  658.       co_expression: {
  659.          fprintf(f, "co-expression_%ld(%ld)",
  660.             (long)((struct b_coexpr *)BlkLoc(*dp))->id,
  661.             (long)((struct b_coexpr *)BlkLoc(*dp))->size);
  662.          }
  663.  
  664.       tvsubs: {
  665.          /*
  666.           * Produce "v[i+:j] = value" where v is the image of the variable
  667.           *  containing the substring, i is starting position of the substring
  668.           *  j is the length, and value is the string v[i+:j].    If the length
  669.           *  (j) is one, just produce "v[i] = value".
  670.           */
  671.          bp = BlkLoc(*dp);
  672.      dp = VarLoc(bp->tvsubs.ssvar);
  673.          if (is:kywdsubj(bp->tvsubs.ssvar)) {
  674.             fprintf(f, "&subject");
  675.             fflush(f);
  676.             }
  677.          else {
  678.             dp = (dptr)((word *)dp + Offset(bp->tvsubs.ssvar));
  679.             outimage(f, dp, restrict);
  680.             }
  681.  
  682.          if (bp->tvsubs.sslen == 1)
  683.  
  684. #if EBCDIC != 1
  685.             fprintf(f, "[%ld]", (long)bp->tvsubs.sspos);
  686. #else                    /* EBCDIC != 1 */
  687.  
  688.             fprintf(f, "$<%ld$>", (long)bp->tvsubs.sspos);
  689. #endif                    /* EBCDIC != 1 */
  690.  
  691.          else
  692.  
  693. #if EBCDIC != 1
  694.             fprintf(f, "[%ld+:%ld]", (long)bp->tvsubs.sspos,
  695.  
  696. #else                    /* EBCDIC != 1 */
  697.             fprintf(f, "$<%ld+:%ld$>", (long)bp->tvsubs.sspos,
  698. #endif                    /* EBCDIC != 1 */
  699.  
  700.                (long)bp->tvsubs.sslen);
  701.  
  702.          if (Qual(*dp)) {
  703.             if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(*dp))
  704.                return;
  705.             StrLen(q) = bp->tvsubs.sslen;
  706.             StrLoc(q) = StrLoc(*dp) + bp->tvsubs.sspos - 1;
  707.             fprintf(f, " = ");
  708.             outimage(f, &q, restrict);
  709.             }
  710.         }
  711.  
  712.       tvtbl: {
  713.          bp = BlkLoc(*dp);
  714.          /*
  715.           * It is possible that the descriptor that thinks it is pointing
  716.           *  to a table-element trapped variable may actually be pointing
  717.           *  at a table element block which had been converted from a
  718.           *  trapped variable. Check for this first and if it is a table
  719.           *  element block, produce the outimage of its value.
  720.           */
  721.          if (bp->tvtbl.title == T_Telem)
  722.             outimage(f, &bp->tvtbl.tval, restrict);
  723.          else {
  724.             /*
  725.              * It really was a TVTBL - Produce "t[s]" where t is the image of
  726.              *  the table containing the element and s is the image of the
  727.              *  subscript.
  728.              */
  729.         tdp.dword = D_Table;
  730.         BlkLoc(tdp) = bp->tvtbl.clink;
  731.             outimage(f, &tdp, restrict);
  732.  
  733. #if EBCDIC != 1
  734.             putc('[', f);
  735. #else                    /* EBCDIC != 1 */
  736.             putc('$', f);
  737.             putc('<', f);
  738. #endif                    /* EBCDIC != 1 */
  739.  
  740.             outimage(f, &bp->tvtbl.tref, restrict);
  741.  
  742. #if EBCDIC != 1
  743.             putc(']', f);
  744. #else                    /* EBCDIC != 1 */
  745.             putc('$', f);
  746.             putc('>', f);
  747. #endif                    /* EBCDIC != 1 */
  748.  
  749.             }
  750.          }
  751.  
  752.       kywdint: {
  753.          if (VarLoc(*dp) == &kywd_ran)
  754.             fprintf(f, "&random = ");
  755.          else if (VarLoc(*dp) == &kywd_trc)
  756.             fprintf(f, "&trace = ");
  757.          outimage(f, VarLoc(*dp), restrict);
  758.          }
  759.  
  760.       kywdpos: {
  761.          fprintf(f, "&pos = ");
  762.          outimage(f, VarLoc(*dp), restrict);
  763.          }
  764.  
  765.       kywdsubj: {
  766.          fprintf(f, "&subject = ");
  767.          outimage(f, VarLoc(*dp), restrict);
  768.          }
  769.  
  770.       default: { 
  771.          if (is:variable(*dp)) {
  772.             /*
  773.              * *d is a variable.  Print "variable =", dereference it, and 
  774.              *  call outimage to handle the value.
  775.              */
  776.             fprintf(f, "(variable = ");
  777.             dp = (dptr)((word *)VarLoc(*dp) + Offset(*dp));
  778.             outimage(f, dp, restrict);
  779.             putc(')', f);
  780.             }
  781.          else if (Type(*dp) == T_External)
  782.             fprintf(f, "external(%d)",((struct b_external *)BlkLoc(*dp))->blksize);
  783.          else if (Type(*dp) <= MaxType)
  784.             fprintf(f, "%s", blkname[Type(*dp)]);
  785.          else
  786.             syserr("outimage: unknown type");
  787.          }
  788.       }
  789.    }
  790.  
  791. /*
  792.  * printimage - print character c on file f using escape conventions
  793.  *  if c is unprintable, '\', or equal to q.
  794.  */
  795.  
  796. static novalue printimage(f, c, q)
  797. FILE *f;
  798. int c, q;
  799.    {
  800.    if (printable(c)) {
  801.       /*
  802.        * c is printable, but special case ", ', and \.
  803.        */
  804.       switch (c) {
  805.          case '"':
  806.             if (c != q) goto deflt;
  807.             fprintf(f, "\\\"");
  808.             return;
  809.          case '\'':
  810.             if (c != q) goto deflt;
  811.             fprintf(f, "\\'");
  812.             return;
  813.          case '\\':
  814.             fprintf(f, "\\\\");
  815.             return;
  816.          default:
  817.          deflt:
  818.             putc(c, f);
  819.             return;
  820.          }
  821.       }
  822.  
  823.    /*
  824.     * c is some sort of unprintable character.    If it one of the common
  825.     *  ones, produce a special representation for it, otherwise, produce
  826.     *  its hex value.
  827.     */
  828.    switch (c) {
  829.       case '\b':            /* backspace */
  830.          fprintf(f, "\\b");
  831.          return;
  832.  
  833. #if !EBCDIC
  834.       case '\177':            /* delete */
  835. #else                    /* !EBCDIC */
  836.       case '\x07':
  837. #endif                    /* !EBCDIC */
  838.  
  839.          fprintf(f, "\\d");
  840.          return;
  841. #if !EBCDIC
  842.       case '\33':            /* escape */
  843. #else                    /* !EBCDIC */
  844.       case '\x27':
  845. #endif                    /* !EBCDIC */
  846.          fprintf(f, "\\e");
  847.          return;
  848.       case '\f':            /* form feed */
  849.          fprintf(f, "\\f");
  850.          return;
  851.       case LineFeed:            /* new line */
  852.          fprintf(f, "\\n");
  853.          return;
  854.  
  855. #if EBCDIC == 1
  856.       case '\x25':                      /* EBCDIC line feed */
  857.          fprintf(f, "\\l");
  858.          return;
  859. #endif                    /* EBCDIC == 1 */
  860.  
  861.       case CarriageReturn:        /* carriage return */
  862.          fprintf(f, "\\r");
  863.          return;
  864.       case '\t':            /* horizontal tab */
  865.          fprintf(f, "\\t");
  866.          return;
  867.       case '\13':            /* vertical tab */
  868.          fprintf(f, "\\v");
  869.          return;
  870.       default:                /* hex escape sequence */
  871.          fprintf(f, "\\x%02x", ToAscii(c & 0xff));
  872.          return;
  873.       }
  874.    }
  875.  
  876. /*
  877.  * listimage - print an image of a list.
  878.  */
  879.  
  880. static novalue listimage(f, lp, restrict)
  881. FILE *f;
  882. struct b_list *lp;
  883. int restrict;
  884.    {
  885.    register word i, j;
  886.    register struct b_lelem *bp;
  887.    word size, count;
  888.  
  889.    bp = (struct b_lelem *) lp->listhead;
  890.    size = lp->size;
  891.  
  892.    if (restrict > 0 && size > 0) {
  893.       /*
  894.        * Just give indication of size if the list isn't empty.
  895.        */
  896.       fprintf(f, "list_%ld(%ld)", (long)lp->id, (long)size);
  897.       return;
  898.       }
  899.  
  900.    /*
  901.     * Print [e1,...,en] on f.  If more than ListLimit elements are in the
  902.     *  list, produce the first ListLimit/2 elements, an ellipsis, and the
  903.     *  last ListLimit elements.
  904.     */
  905.  
  906. #if EBCDIC != 1
  907.    fprintf(f, "list_%ld = [", (long)lp->id);
  908. #else                    /* EBCDIC != 1 */
  909.    fprintf(f, "list_%ld = $<", (long)lp->id);
  910. #endif                /* EBCDIC != 1 */
  911.  
  912.    count = 1;
  913.    i = 0;
  914.    if (size > 0) {
  915.       for (;;) {
  916.          if (++i > bp->nused) {
  917.             i = 1;
  918.             bp = (struct b_lelem *) bp->listnext;
  919.             }
  920.          if (count <= ListLimit/2 || count > size - ListLimit/2) {
  921.             j = bp->first + i - 1;
  922.             if (j >= bp->nslots)
  923.                j -= bp->nslots;
  924.             outimage(f, &bp->lslots[j], restrict+1);
  925.             if (count >= size)
  926.                break;
  927.             putc(',', f);
  928.             }
  929.          else if (count == ListLimit/2 + 1)
  930.             fprintf(f, "...,");
  931.          count++;
  932.          }
  933.       }
  934.  
  935. #if EBCDIC != 1
  936.    putc(']', f);
  937. #else                    /* EBCDIC != 1 */
  938.    putc('$', f);
  939.    putc('>', f);
  940. #endif                    /* EBCDIC != 1 */
  941.  
  942.    }
  943.  
  944. /*
  945.  * qsearch(key,base,nel,width,compar) - binary search
  946.  *
  947.  *  A binary search routine with arguments similar to qsort(3).
  948.  *  Returns a pointer to the item matching "key", or NULL if none.
  949.  *  Based on Bentley, CACM 28,7 (July, 1985), p. 676.
  950.  */
  951.  
  952. char * qsearch (key, base, nel, width, compar)
  953. char * key;
  954. char * base;
  955. int nel, width;
  956. int (*compar)();
  957. {
  958.     int l, u, m, r;
  959.     char * a;
  960.  
  961.     l = 0;
  962.     u = nel - 1;
  963.     while (l <= u) {
  964.     m = (l + u) / 2;
  965.     a = (char *) ((char *) base + width * m);
  966.     r = compar (a, key);
  967.     if (r < 0)
  968.         l = m + 1;
  969.     else if (r > 0)
  970.         u = m - 1;
  971.     else
  972.         return a;
  973.     }
  974.     return 0;
  975. }
  976.  
  977. #if !COMPILER
  978. /*
  979.  * qtos - convert a qualified string named by *dp to a C-style string.
  980.  *  Put the C-style string in sbuf if it will fit, otherwise put it
  981.  *  in the string region.
  982.  */
  983.  
  984. int qtos(dp, sbuf)
  985. dptr dp;
  986. char *sbuf;
  987.    {
  988.    register word slen;
  989.    register char *c, *s;
  990.  
  991.    c = StrLoc(*dp);
  992.    slen = StrLen(*dp)++;
  993.    if (slen >= MaxCvtLen) {
  994.       if (c + slen != strfree) {
  995.          Protect(s = alcstr(c, slen), return Error);
  996.          }
  997.       StrLoc(*dp) = s;
  998.       Protect(alcstr("",(word)1), return Error);
  999.       }
  1000.    else {
  1001.       StrLoc(*dp) = sbuf;
  1002.       for ( ; slen > 0; slen--)
  1003.          *sbuf++ = *c++;
  1004.       *sbuf = '\0';
  1005.       }
  1006.    return Succeeded;
  1007.    }
  1008. #endif                    /* !COMPILER */
  1009.  
  1010. #ifdef Coexpr
  1011. /*
  1012.  * pushact - push actvtr on the activator stack of ce
  1013.  */
  1014. int pushact(ce, actvtr)
  1015. struct b_coexpr *ce, *actvtr;
  1016. {
  1017.    struct astkblk *abp = ce->es_actstk, *nabp;
  1018.    struct actrec *arp;
  1019.  
  1020.  
  1021.    /*
  1022.     * If the last activator is the same as this one, just increment
  1023.     *  its count.
  1024.     */
  1025.    if (abp->nactivators > 0) {
  1026.       arp = &abp->arec[abp->nactivators - 1];
  1027.       if (arp->activator == actvtr) {
  1028.          arp->acount++;
  1029.          return Succeeded;
  1030.          }
  1031.       }
  1032.    /*
  1033.     * This activator is different from the last one.  Push this activator
  1034.     *  on the stack, possibly adding another block.
  1035.     */
  1036.    if (abp->nactivators + 1 > ActStkBlkEnts) {
  1037.       Protect(nabp = alcactiv(), fatalerr(0,NULL));
  1038.       nabp->astk_nxt = abp;
  1039.       abp = nabp;
  1040.       }
  1041.    abp->nactivators++;
  1042.    arp = &abp->arec[abp->nactivators - 1];
  1043.    arp->acount = 1;
  1044.    arp->activator = actvtr;
  1045.    ce->es_actstk = abp;
  1046.    return Succeeded;
  1047. }
  1048. #endif                    /* Coexpr */
  1049.  
  1050. /*
  1051.  * popact - pop the most recent activator from the activator stack of ce
  1052.  *  and return it.
  1053.  */
  1054. struct b_coexpr *popact(ce)
  1055. struct b_coexpr *ce;
  1056. {
  1057.  
  1058. #ifdef Coexpr
  1059.  
  1060.    struct astkblk *abp = ce->es_actstk, *oabp;
  1061.    struct actrec *arp;
  1062.    struct b_coexpr *actvtr;
  1063.  
  1064.  
  1065.    /*
  1066.     * If the current stack block is empty, pop it.
  1067.     */
  1068.    if (abp->nactivators == 0) {
  1069.       oabp = abp;
  1070.       abp = abp->astk_nxt;
  1071.       free((pointer)oabp);
  1072.       }
  1073.  
  1074.    if (abp == NULL || abp->nactivators == 0)
  1075.       syserr("empty activator stack\n");
  1076.  
  1077.    /*
  1078.     * Find the activation record for the most recent co-expression.
  1079.     *  Decrement the activation count and if it is zero, pop that
  1080.     *  activation record and decrement the count of activators.
  1081.     */
  1082.    arp = &abp->arec[abp->nactivators - 1];
  1083.    actvtr = arp->activator;
  1084.    if (--arp->acount == 0)
  1085.       abp->nactivators--;
  1086.  
  1087.    ce->es_actstk = abp;
  1088.    return actvtr;
  1089.  
  1090. #else                    /* Coexpr */
  1091.     syserr("popact() called, but co-expressions not implemented");
  1092. #endif                    /* Coexpr */
  1093.  
  1094. }
  1095.  
  1096. #ifdef Coexpr
  1097. /*
  1098.  * topact - return the most recent activator of ce.
  1099.  */
  1100. struct b_coexpr *topact(ce)
  1101. struct b_coexpr *ce;
  1102. {
  1103.    struct astkblk *abp = ce->es_actstk;
  1104.    
  1105.  
  1106.    if (abp->nactivators == 0)
  1107.       abp = abp->astk_nxt;
  1108.    return abp->arec[abp->nactivators-1].activator;
  1109. }
  1110.  
  1111. #ifdef DeBugIconx
  1112. /*
  1113.  * dumpact - dump an activator stack
  1114.  */
  1115. novalue dumpact(ce)
  1116. struct b_coexpr *ce;
  1117. {
  1118.    struct astkblk *abp = ce->es_actstk;
  1119.    struct actrec *arp;
  1120.    int i;
  1121.  
  1122.    if (abp)
  1123.       fprintf(stderr, "Ce %ld ", (long)ce->id);
  1124.    while (abp) {
  1125.       fprintf(stderr, "--- Activation stack block (%x) --- nact = %d\n",
  1126.          abp, abp->nactivators);
  1127.       for (i = abp->nactivators; i >= 1; i--) {
  1128.          arp = &abp->arec[i-1];
  1129.          /*for (j = 1; j <= arp->acount; j++)*/
  1130.          fprintf(stderr, "co-expression_%ld(%d)\n", (long)(arp->activator->id),
  1131.             arp->acount);
  1132.          }
  1133.       abp = abp->astk_nxt;
  1134.       }
  1135. }
  1136. #endif                    /* DeBugIconx */
  1137. #endif                    /* Coexpr */
  1138.  
  1139. #if !COMPILER
  1140. /*
  1141.  * findline - find the source line number associated with the ipc
  1142.  */
  1143. int findline(ipc)
  1144. word *ipc;
  1145. {
  1146.    uword ipc_offset;
  1147.    uword size;
  1148.    struct ipc_line *base;
  1149.  
  1150.    extern struct ipc_line *ilines, *elines;
  1151.    extern word *records;
  1152.  
  1153.    static two = 2;    /* some compilers generate bad code for division
  1154.                by a constant that is a power of two ... */
  1155.  
  1156.    if (!InRange(code,ipc,records))
  1157.       return 0;
  1158.    ipc_offset = DiffPtrs((char *)ipc,(char *)code);
  1159.    base = ilines;
  1160.    size = DiffPtrs((char *)elines,(char *)ilines) / sizeof(struct ipc_line *);
  1161.    while (size > 1) {
  1162.       if (ipc_offset >= base[size / two].ipc) {
  1163.          base = &base[size / two];
  1164.          size -= size / two;
  1165.          }
  1166.       else
  1167.          size = size / two;
  1168.       }
  1169.    return (int)base->line;
  1170. }
  1171. /*
  1172.  * findipc - find the first ipc associated with a source-code line number.
  1173.  */
  1174. int findipc(line)
  1175. int line;
  1176. {
  1177.    uword size;
  1178.    struct ipc_line *base;
  1179.  
  1180.    extern struct ipc_line *ilines, *elines;
  1181.  
  1182.    static two = 2;    /* some compilers generate bad code for division
  1183.                by a constant that is a power of two ... */
  1184.  
  1185.    base = ilines;
  1186.    size = DiffPtrs((char *)elines,(char *)ilines) / sizeof(struct ipc_line *);
  1187.    while (size > 1) {
  1188.       if (line >= base[size / two].line) {
  1189.          base = &base[size / two];
  1190.          size -= size / two;
  1191.          }
  1192.       else
  1193.          size = size / two;
  1194.       }
  1195.    return base->ipc;
  1196. }
  1197.  
  1198. /*
  1199.  * findfile - find source file name associated with the ipc
  1200.  */
  1201. char *findfile(ipc)
  1202. word *ipc;
  1203. {
  1204.    uword ipc_offset;
  1205.    struct ipc_fname *p;
  1206.  
  1207.    extern struct ipc_fname *filenms, *efilenms;
  1208.    extern word *records;
  1209.  
  1210.    if (!InRange(code,ipc,records))
  1211.       return "?";
  1212.    ipc_offset = DiffPtrs((char *)ipc,(char *)code);
  1213.    for (p = efilenms - 1; p >= filenms; p--)
  1214.       if (ipc_offset >= p->ipc)
  1215.          return strcons + p->fname;
  1216.    fprintf(stderr,"bad ipc/file name table");
  1217.    fflush(stderr);
  1218.    c_exit(ErrorExit);
  1219. }
  1220. #endif                    /* !COMPILER */
  1221.  
  1222. /*
  1223.  * doimage(c,q) - allocate character c in string space, with escape
  1224.  *  conventions if c is unprintable, '\', or equal to q.
  1225.  *  Returns number of characters allocated.
  1226.  */
  1227.  
  1228. doimage(c, q)
  1229. int c, q;
  1230.    {
  1231.    static char cbuf[5];
  1232.  
  1233.    if (printable(c)) {
  1234.  
  1235.       /*
  1236.        * c is printable, but special case ", ', and \.
  1237.        */
  1238.       switch (c) {
  1239.          case '"':
  1240.             if (c != q) goto deflt;
  1241.             Protect(alcstr("\\\"", (word)(2)), return Error);
  1242.             return 2;
  1243.          case '\'':
  1244.             if (c != q) goto deflt;
  1245.             Protect(alcstr("\\'", (word)(2)), return Error);
  1246.             return 2;
  1247.          case '\\':
  1248.             Protect(alcstr("\\\\", (word)(2)), return Error);
  1249.             return 2;
  1250.          default:
  1251.          deflt:
  1252.             cbuf[0] = c;
  1253.             Protect(alcstr(cbuf, (word)(1)), return Error);
  1254.             return 1;
  1255.          }
  1256.       }
  1257.  
  1258.    /*
  1259.     * c is some sort of unprintable character.    If it is one of the common
  1260.     *  ones, produce a special representation for it, otherwise, produce
  1261.     *  its hex value.
  1262.     */
  1263.    switch (c) {
  1264.       case '\b':            /*       backspace    */
  1265.          Protect(alcstr("\\b", (word)(2)), return Error);
  1266.          return 2;
  1267.  
  1268. #if !EBCDIC
  1269.       case '\177':            /*      delete      */
  1270. #else                    /* !EBCDIC */
  1271.       case '\x07':            /*      delete    */
  1272. #endif                    /* !EBCDIC */
  1273.  
  1274.          Protect(alcstr("\\d", (word)(2)), return Error);
  1275.          return 2;
  1276.  
  1277. #if !EBCDIC
  1278.       case '\33':            /*        escape     */
  1279. #else                    /* !EBCDIC */
  1280.       case '\x27':            /*          escape       */
  1281. #endif                    /* !EBCDIC */
  1282.  
  1283.          Protect(alcstr("\\e", (word)(2)), return Error);
  1284.          return 2;
  1285.       case '\f':            /*       form feed    */
  1286.          Protect(alcstr("\\f", (word)(2)), return Error);
  1287.          return 2;
  1288.  
  1289. #if EBCDIC == 1
  1290.       case '\x25':                      /* EBCDIC line feed */
  1291.          Protect(alcstr("\\l", (word)(2)), return Error);
  1292.          return 2;
  1293. #endif                    /* EBCDIC */
  1294.  
  1295.       case LineFeed:            /*       new line    */
  1296.          Protect(alcstr("\\n", (word)(2)), return Error);
  1297.          return 2;
  1298.       case CarriageReturn:        /*       return    */
  1299.          Protect(alcstr("\\r", (word)(2)), return Error);
  1300.          return 2;
  1301.       case '\t':            /*       horizontal tab     */
  1302.          Protect(alcstr("\\t", (word)(2)), return Error);
  1303.          return 2;
  1304.       case '\13':            /*        vertical tab     */
  1305.          Protect(alcstr("\\v", (word)(2)), return Error);
  1306.          return 2;
  1307.       default:                /*      hex escape sequence  */
  1308.          sprintf(cbuf, "\\x%02x", ToAscii(c & 0xff));
  1309.          Protect(alcstr(cbuf, (word)(4)), return Error);
  1310.          return 4;
  1311.       }
  1312.    }
  1313.  
  1314. /*
  1315.  * getimage(dp1,dp2) - return string image of object dp1 in dp2.
  1316.  */
  1317.  
  1318. int getimage(dp1,dp2)
  1319. dptr dp1, dp2;
  1320.    {
  1321.    register word len, outlen, rnlen;
  1322.    int i;
  1323.    tended char *s;
  1324.    tended struct descrip source = *dp1;    /* the source may move during gc */
  1325.    register union block *bp;
  1326.    char *type, *t, *csn;
  1327.    char sbuf[MaxCvtLen];
  1328.    FILE *fd;
  1329.  
  1330.    type_case source of {
  1331.       string: {
  1332.          /*
  1333.           * Form the image by putting a quote in the string space, calling
  1334.           *  doimage with each character in the string, and then putting
  1335.           *  a quote at then end. Note that doimage directly writes into the
  1336.           *  string space.  (Hence the indentation.)  This techinique is used
  1337.           *  several times in this routine.
  1338.           */
  1339.          s = StrLoc(source);
  1340.          len = StrLen(source);
  1341.  
  1342. #ifdef MultiRegion
  1343.      Protect (strreserve((len << 2) + 2), return Error);
  1344. #endif                    /* MultiRegion */
  1345.  
  1346.          Protect(t = alcstr("\"", (word)(1)), return Error);
  1347.          StrLoc(*dp2) = t;
  1348.          StrLen(*dp2) = 1;
  1349.          while (len-- > 0)
  1350.             StrLen(*dp2) += doimage(*s++, '"');
  1351.          Protect(alcstr("\"", (word)(1)), return Error);
  1352.          ++StrLen(*dp2);
  1353.          }
  1354.  
  1355.       null: {
  1356.          StrLoc(*dp2) = "&null";
  1357.          StrLen(*dp2) = 5;
  1358.          }
  1359.  
  1360.       integer: {
  1361. #ifdef LargeInts
  1362.          if (Type(source) == T_Lrgint) {
  1363.             word slen;
  1364.             word dlen;
  1365.  
  1366.             slen = (BlkLoc(source)->bignumblk.lsd - 
  1367.                BlkLoc(source)->bignumblk.msd +1);
  1368.             dlen = slen * NB * 0.3010299956639812;    /* 1 / log2(10) */
  1369.             if (dlen > MaxDigits) {
  1370.                sprintf(sbuf,"integer(~%ld)",dlen - 2); /* center estimate */
  1371.                len = strlen(sbuf);
  1372.                Protect(StrLoc(*dp2) = alcstr(sbuf,strlen(sbuf)), return Error);
  1373.                StrLen(*dp2) = len;
  1374.                }
  1375.         else bigtos(&source,dp2);
  1376.         }
  1377.          else
  1378.             cnv: string(source, *dp2);
  1379. #else                    /* LargeInts */
  1380.          cnv:string(source, *dp2);
  1381. #endif                    /* LargeInts */
  1382.      }
  1383.  
  1384.       real: {
  1385.          cnv:string(source, *dp2);
  1386.          }
  1387.  
  1388.       cset: {
  1389.          /*
  1390.       * Check for the value of a predefined cset; use keyword name if found.
  1391.       */
  1392.      if ((csn = csname(dp1)) != NULL) {
  1393.         StrLoc(*dp2) = csn;
  1394.         StrLen(*dp2) = strlen(csn);
  1395.         return Succeeded;
  1396.         }
  1397.      /*
  1398.       * Otherwise, describe it in terms of the character membership.
  1399.       */
  1400.  
  1401. #ifdef MultiRegion
  1402.      i = BlkLoc(*dp2)->cset.size;
  1403.      if (i < 0)
  1404.         i = cssize(dp2);
  1405.      i = (i << 2) + 2;
  1406.      if (i > 730) i = 730;
  1407.      Protect (strreserve(i), return Error);
  1408. #endif                    /* MultiRegion */
  1409.  
  1410.          Protect(t = alcstr("'", (word)(1)), return Error);
  1411.          StrLoc(*dp2) = t;
  1412.          StrLen(*dp2) = 1;
  1413.          for (i = 0; i < 256; ++i)
  1414.             if (Testb(i, source))
  1415.                StrLen(*dp2) += doimage((char)i, '\'');
  1416.          Protect(alcstr("'", (word)(1)), return Error);
  1417.          ++StrLen(*dp2);
  1418.          }
  1419.  
  1420.       file: {
  1421.          /*
  1422.           * Check for distinguished files by looking at the address of
  1423.           *  of the object to image.  If one is found, make a string
  1424.           *  naming it and return.
  1425.           */
  1426.          if ((fd = BlkLoc(source)->file.fd) == stdin) {
  1427.             StrLen(*dp2) = 6;
  1428.             StrLoc(*dp2) = "&input";
  1429.             }
  1430.          else if (fd == stdout) {
  1431.             StrLen(*dp2) = 7;
  1432.             StrLoc(*dp2) = "&output";
  1433.             }
  1434.          else if (fd == stderr) {
  1435.             StrLen(*dp2) = 7;
  1436.             StrLoc(*dp2) = "&errout";
  1437.             }
  1438.          else {
  1439.             /*
  1440.              * The file is not a standard one; form a string of the form
  1441.              *    file(nm) where nm is the argument originally given to
  1442.              *    open.
  1443.              */
  1444.             len = StrLen(BlkLoc(source)->file.fname);
  1445.             s = StrLoc(BlkLoc(source)->file.fname);
  1446. #ifdef MultiRegion
  1447.             Protect (strreserve((len << 2) + 10), return Error);
  1448. #endif                    /* MultiRegion */
  1449.             Protect(t = alcstr("file(", (word)(5)), return Error);
  1450.             StrLoc(*dp2) = t;
  1451.             StrLen(*dp2) = 5;
  1452.             while (len-- > 0)
  1453.                StrLen(*dp2) += doimage(*s++, '\0');
  1454.             Protect(alcstr(")", (word)(1)), return Error);
  1455.             ++StrLen(*dp2);
  1456.             }
  1457.          }
  1458.  
  1459.       procedure: {
  1460.          /*
  1461.           * Produce one of:
  1462.           *  "procedure name"
  1463.           *  "function name"
  1464.           *  "record constructor name"
  1465.           *
  1466.           * Note that the number of dynamic locals is used to determine
  1467.           *  what type of "procedure" is at hand.
  1468.           */
  1469.          len = StrLen(BlkLoc(source)->proc.pname);
  1470.          s = StrLoc(BlkLoc(source)->proc.pname);
  1471. #ifdef MultiRegion
  1472.      Protect (strreserve(len + 22), return Error);
  1473. #endif                    /* MultiRegion */
  1474.          switch ((int)BlkLoc(source)->proc.ndynam) {
  1475.             default:  type = "procedure "; break;
  1476.             case -1:  type = "function "; break;
  1477.             case -2:  type = "record constructor "; break;
  1478.             }
  1479.          outlen = strlen(type);
  1480.          Protect(t = alcstr(type, outlen), return Error);
  1481.          StrLoc(*dp2) = t;
  1482.          Protect(alcstr(s, len),  return Error);
  1483.          StrLen(*dp2) = len + outlen;
  1484.          }
  1485.  
  1486.       list: {
  1487.          /*
  1488.           * Produce:
  1489.           *  "list_m(n)"
  1490.           * where n is the current size of the list.
  1491.           */
  1492.          bp = BlkLoc(*dp1);
  1493.          sprintf(sbuf, "list_%ld(%ld)", (long)bp->list.id, (long)bp->list.size);
  1494.          len = strlen(sbuf);
  1495.          Protect(t = alcstr(sbuf, len), return Error);
  1496.          StrLoc(*dp2) = t;
  1497.          StrLen(*dp2) = len;
  1498.          }
  1499.  
  1500.       table: {
  1501.          /*
  1502.           * Produce:
  1503.           *  "table_m(n)"
  1504.           * where n is the size of the table.
  1505.           */
  1506.          bp = BlkLoc(*dp1);
  1507.          sprintf(sbuf, "table_%ld(%ld)", (long)bp->table.id,
  1508.             (long)bp->table.size);
  1509.          len = strlen(sbuf);
  1510.          Protect(t = alcstr(sbuf, len), return Error);
  1511.          StrLoc(*dp2) = t;
  1512.          StrLen(*dp2) = len;
  1513.          }
  1514.  
  1515.       set: {
  1516.          /*
  1517.           * Produce "set_m(n)" where n is size of the set.
  1518.           */
  1519.          bp = BlkLoc(*dp1);
  1520.          sprintf(sbuf, "set_%ld(%ld)", (long)bp->set.id, (long)bp->set.size);
  1521.          len = strlen(sbuf);
  1522.          Protect(t = alcstr(sbuf,len), return Error);
  1523.          StrLoc(*dp2) = t;
  1524.          StrLen(*dp2) = len;
  1525.          }
  1526.  
  1527.       record: {
  1528.          /*
  1529.           * Produce:
  1530.           *  "record name_m(n)"    -- under construction
  1531.           * where n is the number of fields.
  1532.           */
  1533.          bp = BlkLoc(*dp1);
  1534.          rnlen = StrLen(bp->record.recdesc->proc.recname);
  1535.          bp = BlkLoc(*dp1);
  1536.          sprintf(sbuf, "_%ld(%ld)", (long)bp->record.id,
  1537.             (long)bp->record.recdesc->proc.nfields);
  1538.          len = strlen(sbuf);
  1539. #ifdef MultiRegion
  1540.      Protect (strreserve(7 + len + rnlen), return Error);
  1541. #endif                    /* MultiRegion */
  1542.          Protect(t = alcstr("record ", (word)(7)), return Error);
  1543.          StrLoc(*dp2) = t;
  1544.          Protect(alcstr(StrLoc(bp->record.recdesc->proc.recname),rnlen),
  1545.                 return Error);
  1546.          Protect(alcstr(sbuf, len),  return Error);
  1547.          StrLen(*dp2) = 7 + len + rnlen;
  1548.          }
  1549.  
  1550.       co_expression: {
  1551.          /*
  1552.           * Produce:
  1553.           *  "co-expression_m (n)"
  1554.           *  where m is the number of the co-expressions and n is the
  1555.           *  number of results that have been produced.
  1556.           */
  1557.  
  1558.          sprintf(sbuf, "_%ld(%ld)", (long)BlkLoc(source)->coexpr.id,
  1559.             (long)BlkLoc(source)->coexpr.size);
  1560.          len = strlen(sbuf);
  1561. #ifdef MultiRegion
  1562.      Protect (strreserve(len + 13), return Error);
  1563. #endif                    /* MultiRegion */
  1564.          Protect(t = alcstr("co-expression", (word)(13)), return Error);
  1565.          StrLoc(*dp2) = t;
  1566.          Protect(alcstr(sbuf, len), return Error);
  1567.          StrLen(*dp2) = 13 + len;
  1568.          }
  1569.  
  1570.       default:
  1571.         if (Type(*dp1) == T_External) {
  1572.            /*
  1573.             * For now, just produce "external(n)". 
  1574.             */
  1575.            sprintf(sbuf, "external(%ld)", (long)BlkLoc(*dp1)->externl.blksize);
  1576.            len = strlen(sbuf);
  1577.            Protect(t = alcstr(sbuf, len), return Error);
  1578.            StrLoc(*dp2) = t;
  1579.            StrLen(*dp2) = len;
  1580.            }
  1581.          else {
  1582.         ReturnErrVal(123, source, Error);
  1583.             }
  1584.       }
  1585.    return Succeeded;
  1586.    }
  1587.  
  1588. /*
  1589.  * csname(dp) -- return the name of a predefined cset matching dp.
  1590.  */
  1591. static char *csname(dp)
  1592. dptr dp;
  1593.    {
  1594.    register int j, n;
  1595.    register unsigned int w;
  1596.  
  1597.    n = BlkLoc(*dp)->cset.size;
  1598.    if (n < 0) 
  1599.       n = cssize(dp);
  1600.  
  1601. #if EBCDIC != 1
  1602.    /*
  1603.     * Check for a cset we recognize using a hardwired decision tree.
  1604.     *  In ASCII, each of &lcase/&ucase/&digits are complete within 32 bits.
  1605.     */
  1606.    if (n == 52) {
  1607.       if ((Cset32('a',*dp) & Cset32('A',*dp)) == (0377777777l << CsetOff('a')))
  1608.      return ("&letters");
  1609.       }
  1610.    else if (n < 52) {
  1611.       if (n == 26) {
  1612.      if (Cset32('a',*dp) == (0377777777l << CsetOff('a')))
  1613.         return ("&lcase");
  1614.      else if (Cset32('A',*dp) == (0377777777l << CsetOff('A')))
  1615.         return ("&ucase");
  1616.      }
  1617.       else if (n == 10 && *CsetPtr('0',*dp) == (01777 << CsetOff('0')))
  1618.      return ("&digits");
  1619.       }
  1620.    else /* n > 52 */ {
  1621.       if (n == 256)
  1622.      return "&cset";
  1623.       else if (n == 128 && ~0 ==
  1624.      (Cset32(0,*dp) & Cset32(32,*dp) & Cset32(64,*dp) & Cset32(96,*dp)))
  1625.         return "&ascii";
  1626.       }
  1627.    return NULL;
  1628. #else                        /* EBCDIC != 1 */
  1629.    /*
  1630.     * Check for a cset we recognize using a hardwired decision tree.
  1631.     *  In EBCDIC, the neither &lcase nor &ucase is contiguous.
  1632.     *  #%#% THIS CODE HAS NOT YET BEEN TESTED.
  1633.     */
  1634.    if (n == 52) {
  1635.       if ((Cset32(0x80,*dp) & Cset32(0xC0,*dp)) == 0x03FE03FE
  1636.          && Cset32(0xA0,*dp) & Cset32(0xE0,*dp)) == 0x03FC)
  1637.         return ("&letters");
  1638.       }
  1639.    else if (n < 52) {
  1640.       if (n == 26) {
  1641.      if (Cset32(0x80,*dp) == 0x03FE03FE && Cset32(0xA0,*dp) == 0x03FC)
  1642.         return ("&lcase");
  1643.      else if (Cset32(0xC0,*dp) == 0x03FE03FE && Cset32(0xE0,*dp) == 0x03FC)
  1644.         return ("&ucase");
  1645.      }
  1646.       else if (n == 10 && *CsetPtr('0',*dp) == (01777 << CsetOff('0')))
  1647.      return ("&digits");
  1648.       }
  1649.    else /* n > 52 */ {
  1650.       if (n == 256)
  1651.      return "&cset";
  1652.       else if (n == 128 && equiv(dp, &k_ascii))
  1653.         return "&ascii";
  1654.       }
  1655.    return NULL;
  1656. #endif                        /* EBCDIC != 1 */
  1657.    }
  1658.  
  1659. /*
  1660.  * cssize(dp) - calculate cset size, store it, and return it
  1661.  */
  1662. int cssize(dp)
  1663. dptr dp;
  1664. {
  1665.    register int i, n;
  1666.    register unsigned int w, *wp;
  1667.    register struct b_cset *cs;
  1668.  
  1669.    cs = &BlkLoc(*dp)->cset;
  1670.    wp = (unsigned int *)cs->bits;
  1671.    n = 0;
  1672.    for (i = CsetSize; --i >= 0; )
  1673.       for (w = *wp++; w != 0; w >>= 1)
  1674.      n += (w & 1);
  1675.    cs->size = n;
  1676.    return n;
  1677. }
  1678.  
  1679. /*
  1680.  * printable(c) -- is c a "printable" character?
  1681.  */
  1682.  
  1683. int printable(c)
  1684. int c;
  1685.    {
  1686.  
  1687. /*
  1688.  * The following code is operating-system dependent [@rmisc.01].
  1689.  *  Determine if a character is "printable".
  1690.  */
  1691.  
  1692. #if PORT
  1693.    return isprint(c);
  1694. Deliberate Syntax Error
  1695. #endif                    /* PORT */
  1696.  
  1697. #if AMIGA || ATARI_ST || MSDOS || OS2 || UNIX || VMS
  1698.    return (isascii(c) && isprint(c));
  1699. #endif                    /* AMIGA || ATARI_ST ... */
  1700.  
  1701. #if ARM
  1702.    return (c >= 0x00 && c <= 0x7F && isprint(c));
  1703. #endif                    /* ARM */
  1704.  
  1705. #if MACINTOSH
  1706. #if MPW
  1707.    return (isascii(c) && isprint(c));
  1708. #else                    /* MPW */
  1709.    return isprint(c);
  1710. #endif                    /* MPW */
  1711. #endif                    /* MACINTOSH */
  1712.  
  1713. #if MVS || VM
  1714. #if SASC
  1715.    return isascii(c) && !iscntrl(c);
  1716. #else                    /* SASC */
  1717.    return isprint(c);
  1718. #endif                    /* SASC */
  1719. #endif                                  /* MVS || VM */
  1720.  
  1721. /*
  1722.  * End of operating-system specific code.
  1723.  */
  1724.    }
  1725.  
  1726. #ifndef AsmOver
  1727. /*
  1728.  * add, sub, mul, neg with overflow check
  1729.  * all return 1 if ok, 0 if would overflow
  1730.  */
  1731.  
  1732. /*
  1733.  *  Note: on some systems an improvement in performance can be obtained by
  1734.  *  replacing the C functions that follow by checks written in assembly
  1735.  *  language.  To do so, add #define AsmOver to ../h/define.h.  If your
  1736.  *  C compiler supports the asm directive, but the new code at the end
  1737.  *  of this section under control of #else.  Otherwise put it a separate
  1738.  *  file.
  1739.  */
  1740.  
  1741. extern int over_flow;
  1742.  
  1743. word add(a, b)
  1744. word a, b;
  1745. {
  1746.    if ((a ^ b) >= 0 && (a >= 0 ? b > MaxLong - a : b < MinLong - a)) {
  1747.       over_flow = 1;
  1748.       return 0;
  1749.       }
  1750.    else {
  1751.      over_flow = 0;
  1752.      return a + b;
  1753.      }
  1754. }
  1755.  
  1756. word sub(a, b)
  1757. word a, b;
  1758. {
  1759.    if ((a ^ b) < 0 && (a >= 0 ? b < a - MaxLong : b > a - MinLong)) {
  1760.       over_flow = 1;
  1761.       return 0;
  1762.       }
  1763.    else {
  1764.       over_flow = 0;
  1765.       return a - b;
  1766.       }
  1767. }
  1768.  
  1769. word mul(a, b)
  1770. word a, b;
  1771. {
  1772.    if (b != 0) {
  1773.       if ((a ^ b) >= 0) {
  1774.      if (a >= 0 ? a > MaxLong / b : a < MaxLong / b) {
  1775.             over_flow = 1;
  1776.         return 0;
  1777.             }
  1778.      }
  1779.       else if (b != -1 && (a >= 0 ? a > MinLong / b : a < MinLong / b)) {
  1780.          over_flow = 1;
  1781.      return 0;
  1782.          }
  1783.       }
  1784.  
  1785.    over_flow = 0;
  1786.    return a * b;
  1787. }
  1788.  
  1789. /* MinLong / -1 overflows; need div3 too */
  1790.  
  1791. word neg(a)
  1792. word a;
  1793. {
  1794.    if (a == MinLong) {
  1795.       over_flow = 1;
  1796.       return 0;
  1797.       }
  1798.    over_flow = 0;
  1799.    return -a;
  1800. }
  1801. #endif                    /* AsmOver */
  1802.  
  1803. #if COMPILER
  1804. /*
  1805.  * sig_rsm - standard success continuation that just signals resumption.
  1806.  */
  1807.  
  1808. int sig_rsm()
  1809.    {
  1810.    return A_Resume;
  1811.    }
  1812.  
  1813. /*
  1814.  * cmd_line - convert command line arguments into a list of strings.
  1815.  */
  1816. novalue cmd_line(argc, argv, rslt)
  1817. int argc;
  1818. char **argv;
  1819. dptr rslt;
  1820.    {
  1821.    tended struct b_list *hp;
  1822.    register word i;
  1823.    register struct b_lelem *bp;  /* need not be tended */
  1824.  
  1825.    /*
  1826.     * Skip the program name.
  1827.     */
  1828.    --argc;
  1829.    ++argv;
  1830.  
  1831.    /*
  1832.     * Allocate the list and a list block.
  1833.     */
  1834.    Protect(hp = alclist(argc), fatalerr(0,NULL));
  1835.    Protect(bp = alclstb(argc, (word)0, argc), fatalerr(0,NULL));
  1836.  
  1837.    /*
  1838.     * Make the list block just allocated into the first and last blocks
  1839.     *  for the list.
  1840.     */
  1841.    hp->listhead = hp->listtail = (union block *)bp;
  1842.  
  1843.    /*
  1844.     * Copy the arguments into the list
  1845.     */
  1846.    for (i = 0; i < argc; ++i) {
  1847.       StrLen(bp->lslots[i]) = strlen(argv[i]);
  1848.       StrLoc(bp->lslots[i]) = argv[i];
  1849.       }
  1850.  
  1851.    rslt->dword = D_List;
  1852.    rslt->vword.bptr = (union block *) hp;
  1853.    }
  1854.  
  1855. /*
  1856.  * varargs - construct list for use in procedures with variable length
  1857.  *  argument list.
  1858.  */
  1859. novalue varargs(argp, nargs, rslt)
  1860. dptr argp;
  1861. int nargs;
  1862. dptr rslt;
  1863.    {
  1864.    tended struct b_list *hp;
  1865.    register word i;
  1866.    register struct b_lelem *bp;  /* need not be tended */
  1867.  
  1868.    /*
  1869.     * Allocate the list and a list block.
  1870.     */
  1871.    Protect(hp = alclist(nargs), fatalerr(0,NULL));
  1872.    Protect(bp = alclstb(nargs, (word)0, nargs), fatalerr(0,NULL));
  1873.  
  1874.    /*
  1875.     * Make the list block just allocated into the first and last blocks
  1876.     *  for the list.
  1877.     */
  1878.    hp->listhead = hp->listtail = (union block *)bp;
  1879.  
  1880.    /*
  1881.     * Copy the arguments into the list
  1882.     */
  1883.    for (i = 0; i < nargs; i++)
  1884.       deref(&argp[i], &bp->lslots[i]);
  1885.  
  1886.    rslt->dword = D_List;
  1887.    rslt->vword.bptr = (union block *) hp;
  1888.    }
  1889. #endif                    /* COMPILER */
  1890.